home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / abcl / abclr.lha / abclr / sys / object.abcl1 < prev    next >
Lisp/Scheme  |  1988-11-26  |  4KB  |  128 lines
  1. ;;; -*- Mode: ABCL; Syntax: Common-lisp; Package: USER; Base: 10 -*-
  2. ;;;
  3. ;;; ABCL/R system                          Takuo Watanabe (Apr. 1988)
  4. ;;; Meta-Objects
  5.  
  6. (defvar *reifying-meta-obj-script-text*)
  7.  
  8. ;;; generator of meta-objects
  9. [object object-gen
  10.   (script
  11.    (=> [:new Vars Lex-Env Scripts]
  12.        (temporary [Me-ptr := [reifying-pointer-gen <== :new]]
  13.           raw-object)
  14.        [raw-object
  15.     := [object object
  16.          (state [queue := '()]
  17.             [state := [state-gen <== [:new Vars Lex-Env]]]
  18.             [scriptset := Scripts]
  19.             [evaluator := [eval-gen <== :new]]
  20.             [mode := :dormant]
  21.             )
  22.          (script
  23.           (=> [:message Message Reply Sender]
  24.           [queue := (enqueue queue [Message Reply Sender])]
  25.           (if (eq mode :dormant)
  26.               (progn [mode := :active]
  27.                  [Me-ptr <= :begin])))
  28.           (=> :begin
  29.           (let* ((mrs (first queue))
  30.              (scr (find-script (first mrs) scriptset)))
  31.             [queue := (dequeue queue)]
  32.             (if scr
  33.             [evaluator
  34.              <= [:do-prg (scr$body scr)
  35.                      [env-gen
  36.                       <== [:new (script-alist mrs scr)
  37.                         state]]
  38.                      Me-ptr]
  39.              @ (cont ignore
  40.                  [Me-ptr <= :end])]
  41.             (progn
  42.               (warn "~S cannot handle the message ~S"
  43.                 (name-of Me-ptr) (first mrs))
  44.               (if (second mrs)
  45.                   [(second mrs) <= [:message nil nil Me-ptr]])
  46.               [Me-ptr <= :end]))))
  47.           (=> :end
  48.           (if (empty? queue)
  49.               [mode := :dormant]
  50.               [Me-ptr <= :begin]))
  51.           (=> :reified-meta
  52.           ![object-gen
  53.             <== [:new (list (list 'queue queue)
  54.                     (list 'state
  55.                       [state <== :to-ABCLR])
  56.                     (list 'scriptset scriptset)
  57.                     (list 'evaluator
  58.                       [evaluator <== :to-ABCLR])
  59.                     (list 'mode mode))
  60.                   global-env
  61.                   *reifying-meta-obj-script-text*]])
  62.           )]]
  63.        [Me-ptr <== [:set-object raw-object]]
  64.        !Me-ptr)
  65.    )]
  66.  
  67. (eval-when (load eval)
  68.   (setq *reifying-meta-obj-script-text*
  69.     '((=> [:message Message Reply Sender]
  70.        [queue := (nconc queue (list [Message Reply Sender]))]
  71.        (if (eq mode :dormant) then
  72.            [mode := :active]
  73.            [Me <= :begin]))
  74.       (=> :begin
  75.        (temporary [object := Me] mrs scr newenv)
  76.        (if (null queue) then
  77.            (warn "~&Empty queue on ~S" (name-of [den Me])))
  78.        [mrs := (car queue)]
  79.        [queue := (cdr queue)]
  80.        [scr := (find-script (first mrs) scriptset)]
  81.        (if scr then
  82.            [newenv := [env-gen
  83.                <== [:new (script-alist mrs scr) state]]]
  84.            [evaluator <= [:do-prg (scr$body scr) newenv [den Me]] @
  85.               [cont ignore
  86.                 [object <= :end]]]
  87.            else
  88.            (warn "~S cannot handle the message ~S"
  89.              (name-of [den Me]) (first mrs))
  90.            [(second mrs) <= nil]
  91.            [object <= :end]))
  92.       (=> :end
  93.        (if queue then
  94.            [Me <= :begin]
  95.            else
  96.            [mode := :dormant]))
  97.       (=> :queue
  98.        !queue)
  99.       (=> [:set-queue New-Queue]
  100.        ![queue := New-Queue])
  101.       (=> :state
  102.        !state)
  103.       (=> [:set-state New-State]
  104.        ![state := New-State])
  105.       (=> :scriptset
  106.        !scriptset)
  107.       (=> [:set-scriptset New-ScriptSet]
  108.        ![scriptset := New-ScriptSet])
  109.       (=> [:script Message]
  110.        !(find-script Message scriptset))
  111.       (=> [:add-script New-Script]
  112.        (temporary [s := (digest New-Script)])
  113.        [scriptset := (add-script-list s scriptset)]
  114.        !s)
  115.       (=> [:delete-script Message] @ C
  116.        (temporary [script := (find-script Message scriptset)])
  117.        [scriptset := (delete script scriptset)]
  118.        !script)
  119.       (=> :evaluator
  120.        !evaluator)
  121.       (=> [:set-evaluator New-Evaluator]
  122.        ![evaluator := New-Evaluator])
  123.       (=> :mode
  124.        !mode)
  125.       ))
  126.   )
  127.  
  128.